home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tptc16.zip
/
TEST.SRC
< prev
next >
Wrap
Text File
|
1993-01-04
|
11KB
|
480 lines
MODULE MENUS;
CONST
{$I MENUS.CON}
{$I CONTROLS.CON}
{$I SWITCH.CON}
ASK = TRUE;
DONT_ASK = FALSE;
TYPE
{$I TELEX.DEF}
VAR
{$I TELEX.GLB}
HELPANS: BOOLEAN;
SELECT: CHAR;
SLINE: INTEGER;
REPAINT: BOOLEAN;
DUMMY_B: BOOLEAN;
DATE: STRING[12];
REVS: BYTE;
WAIT_PERIOD: LONGINT;
IN_TOP_LEVEL: EXTERNAL BOOLEAN;
MNS: EXTERNAL ARRAY [1..200] OF STRING[40];
L_MARGIN: EXTERNAL BYTE;
T_MARGIN: EXTERNAL BYTE;
R_MARGIN: EXTERNAL BYTE;
B_MARGIN: EXTERNAL BYTE;
COMSEL: EXTERNAL BYTE;
ATTR: EXTERNAL INTEGER;
FUNCS: EXTERNAL ARRAY[0..31] OF BYTE;
MISC: EXTERNAL ARRAY[1..16] OF BYTE;
UNS1: EXTERNAL STRING;
WTANS: EXTERNAL LONGINT;
{$I TERMINAL.EXT}
EXTERNAL PROCEDURE PUTCHRS(CH: CHAR ; CNT: INTEGER);
(*------- notice the external declaration -------*)
EXTERNAL PROCEDURE CLEAR_WINDOW(ULX,ULY,LRX,LRY: INTEGER);
EXTERNAL PROCEDURE PUTATPOS(CH:CHAR);
EXTERNAL FUNCTION READ_CHR: INTEGER;
EXTERNAL FUNCTION READXY: INTEGER;
EXTERNAL FUNCTION WAIT_FOR_CHAR: CHAR;
EXTERNAL FUNCTION GET_CHR_AND_MESSAGES: CHAR;
EXTERNAL FUNCTION SYS_TICK: LONGINT;
EXTERNAL PROCEDURE ANSWER;
EXTERNAL PROCEDURE HELP;
EXTERNAL PROCEDURE DELAY;
EXTERNAL PROCEDURE BEEP;
EXTERNAL PROCEDURE GET_STATUS(VAR S: STRING);
EXTERNAL PROCEDURE STR_OUT(S: STRING);
EXTERNAL [1] PROCEDURE EDIT;
(*------- notice the external declaration in an overlay #1 -------*)
EXTERNAL [2] PROCEDURE PREPARE;
EXTERNAL [2] PROCEDURE SAVE_SYS_PARMS;
EXTERNAL [5] PROCEDURE LOAD_MSG;
EXTERNAL [5] PROCEDURE SAVE_MSG;
EXTERNAL [5] PROCEDURE KILL_MSG;
EXTERNAL [5] PROCEDURE VIEW_MSG;
EXTERNAL [5] PROCEDURE LDIR_MSG;
EXTERNAL [5] PROCEDURE ADJUST;
EXTERNAL [5] PROCEDURE CHANGE_LANG;
EXTERNAL [5] PROCEDURE CHANGE_MODE;
EXTERNAL [6] PROCEDURE READ_TELEX;
EXTERNAL [7] PROCEDURE INDEX;
EXTERNAL [7] PROCEDURE DEL_INDEX;
EXTERNAL [8] PROCEDURE LIST_TELEX;
EXTERNAL [9] PROCEDURE REVIEW;
EXTERNAL [10] FUNCTION RETRIEVE(C: INTEGER): BOOLEAN;
EXTERNAL [10] PROCEDURE CLR_COPY;
EXTERNAL [11] PROCEDURE DOTHINGS;
EXTERNAL [17] PROCEDURE PHONE;
EXTERNAL [18] PROCEDURE WELCOME;
EXTERNAL [21] PROCEDURE SEND(ASK_TIME: BOOLEAN);
EXTERNAL [21] FUNCTION MULTI_SEND: INTEGER;
EXTERNAL [22] PROCEDURE ONLINE;
EXTERNAL [22] PROCEDURE CALL_SUBSCRIBER;
EXTERNAL [23] PROCEDURE CONFIG;
EXTERNAL [24] FUNCTION QUIT: BOOLEAN;
EXTERNAL [25] PROCEDURE PUT_DATE(I: INTEGER ; OD: CHAR);
EXTERNAL [26] PROCEDURE PRINT_CONTENTS;
EXTERNAL [26] PROCEDURE GET_LOGGED_MESSAGE;
FUNCTION MENU_DRIVER(LTR: STRING ;START_ROW: INTEGER): CHAR;
VAR
LOG_ON_DISK: BOOLEAN;
CH,N: INTEGER;
BEGIN
N := LENGTH(LTR) - 1;
IF SP1STR = UNS1 THEN
LOG_ON_DISK := TRUE
ELSE
LOG_ON_DISK := FALSE;
XYGOTO(80,1);
REPEAT
REPEAT
IF IN_TOP_LEVEL AND LOG_ON_DISK THEN
CH := ORD(GET_CHR_AND_MESSAGES)
ELSE
CH := ORD(WAIT_FOR_CHAR);
UNTIL (CH = 27) OR (CH = FUNC_KEY);
IF CH <> 27 THEN
CH := ORD(GET_CHR);
UNTIL ((CH >= F1_KEY) AND (CH <= F1_KEY+N)) OR (CH = 27);
IF CH = 27 THEN
MENU_DRIVER := 'Q'
ELSE
BEGIN
N := CH - F1_KEY;
MENU_DRIVER := LTR[N+1];
END;
END;
PROCEDURE SET_DATE(S: STRING);
BEGIN
DATE := S;
ATTR := HILT; XYGOTO(60,1); WRITE([ADDR(PUT_CHR)],DATE);
ATTR := NORMAL;
END;
PROCEDURE EXEC_PROC;
VAR
S: STRING;
C: CHAR;
BEGIN
IF MISC_PARMS[4] <> 0 THEN
BEGIN
GET_STATUS(S);
C := S[POS('P5',S)+2];
IF NOT (C IN ['3','4']) THEN
BEGIN
MISC_PARMS[4] := 0;
XYGOTO(2,22); DRAW_HORIZ;
END;
END;
END;
PROCEDURE INVOKE_FUNC(P: INTEGER);
BEGIN
CASE P OF
1: IF HELPANS THEN BEGIN HELPANS := FALSE; ANSWER; HELPANS := TRUE; END;
8: HELP;
16: PRINT_SCREEN;
20: ABORT_SEND;
END;
END;
PROCEDURE ABORT_SEND;
BEGIN
STR_OUT('{T}');
END;
PROCEDURE PRINT_SCREEN;
VAR
C,P,X,Y: INTEGER;
AT: BYTE;
PROCEDURE CRLF;
BEGIN
PRN_CHR(CHR(13));
PRN_CHR(CHR(10));
END;
(*PROCEDURE CHANGE_ATTR;
VAR
A: BYTE;
BEGIN
A := HI(C);
IF A = HLUL THEN
WRITE([ADDR(PRN_CHR)],CHR(27),'-1')
ELSE
WRITE([ADDR(PRN_CHR)],CHR(27),'-0');
AT := A;
END;*)
PROCEDURE SWITCH(CH: CHAR);
BEGIN
C := (C & $FF00) ! ORD(CH);
(*---- ^ this is a bit-wise OR ----*)
(*---- ^ this is a bit-wise AND ----*)
END;
BEGIN
P := READXY; AT := NORMAL;
(*WRITE([ADDR(PRN_CHR)],CHR(27),'U1');*)
CRLF;
FOR Y := 1 TO 25 DO
BEGIN
FOR X := 1 TO 80 DO
BEGIN
XYGOTO(X,Y);
C := READ_CHR;
CASE CHR(LO(C)) OF
'╠','╣','╔','╚','╝','╗': SWITCH('+');
'═': SWITCH('-');
'║': SWITCH('|');
END;
(*IF AT <> HI(C) THEN
CHANGE_ATTR;*)
PRN_CHR(CHR(LO(C)));
END;
CRLF;
END;
(* WRITE([ADDR(PRN_CHR)],CHR(27),'-0',CHR(27),'U0');*)
CRLF; CRLF; CRLF;
XYGOTO(LO(P)+1,HI(P)+1);
END;
PROCEDURE DEF_WINDOW(P: CHAR);
BEGIN
LINE_WIDTH(1);
CASE P OF
'A':
BEGIN
LINE_WIDTH(0); T_MARGIN := 0; B_MARGIN := 24; XYGOTO(1,1);
END;
'L':
BEGIN
T_MARGIN := 4; B_MARGIN := 20; XYGOTO(2,5);
END;
'S':
BEGIN
T_MARGIN := 1; B_MARGIN := 2; XYGOTO(2,2);
END;
'B':
BEGIN
T_MARGIN := 22; B_MARGIN := 23; XYGOTO(2,22);
END;
END;
END;
PROCEDURE LINE_WIDTH(I: INTEGER);
BEGIN
L_MARGIN := I; R_MARGIN := 79 - I;
END;
PROCEDURE PUT_SELECTION(IX: INTEGER);
VAR
ATR: INTEGER;
BEGIN
XYGOTO(20,SLINE); ATR := ATTR; ATTR := HILT;
WRITELN([ADDR(PUT_CHR)],'F',SELECT,' ',MNS[IX]);
SELECT := CHR(ORD(SELECT) + 1);
SLINE := SLINE + 2;
WRITELN([ADDR(PUT_CHR)]);
ATTR := ATR;
END;
PROCEDURE DRAW_HORIZ;
VAR
N: INTEGER;
BEGIN
FOR N := 2 TO 79 DO PUT_CHR(CHR(205));
END;
PROCEDURE REPNT;
BEGIN
REPAINT := TRUE;
END;
PROCEDURE NOREPNT;
BEGIN
REPAINT := FALSE;
END;
PROCEDURE SWITCH(CH: CHAR);
BEGIN
C := (C & $FF00) ! ORD(CH);
(* ^ this is a bit-wise OR *)
(* ^ this is a bit-wise AND *)
END;
PROCEDURE PUTCONSTR(SI: INTEGER ; X,Y: INTEGER);
VAR
SAVE_ATTR: BYTE;
BEGIN
SAVE_ATTR := ATTR;
IF X >= 100 THEN
BEGIN
ATTR := HILT;
X := X - 100;
END;
IF Y > 0 THEN
XYGOTO(X,Y)
ELSE
FOR X := X DOWNTO 1 DO PUT_CHR(' ');
WRITE([ADDR(PUT_CHR)],MNS[SI]);
ATTR := SAVE_ATTR;
END;
PROCEDURE CLR_L_WND;
BEGIN
CLEAR_WINDOW(2,5,79,21);
END;
PROCEDURE CLR_S_WND;
BEGIN
CLEAR_WINDOW(2,2,79,3);
END;
PROCEDURE CLR_B_WND;
BEGIN
CLEAR_WINDOW(2,23,79,24);
END;
FUNCTION TEST_PSWD(X,Y: INTEGER): BOOLEAN;
VAR
I: INTEGER;
CH: CHAR;
S: STRING;
BEGIN
TEST_PSWD := FALSE;
PUTCONSTR(PSWD,100+X,Y); CL_EOL;
S := '';
REPEAT
CH := WAIT_FOR_CHAR;
IF CH = CHR(27) THEN BEGIN XYGOTO(X,Y); CL_EOL; EXIT; END;
S := CONCAT(S,CH);
UNTIL CH = CHR(13);
DELETE(S,LENGTH(S),1);
IF S = PASSWORD THEN TEST_PSWD := TRUE;
XYGOTO(X,Y); CL_EOL;
END;
PROCEDURE INIT_MENU;
BEGIN
SELECT := '1';
SLINE := 6;
END;
{$E-}
PROCEDURE CHECK_CONNECT;
VAR
P: INTEGER;
AT: BYTE;
BEGIN
AT := ATTR;
IF MISC_PARMS[4] <> 0 THEN
BEGIN
P := 40 - LENGTH(MNS[CLSC]) DIV 2;
ATTR := 112; PUTCONSTR(CLSC,P,22);
END
ELSE
BEGIN
XYGOTO(2,22); DRAW_HORIZ;
END;
ATTR := AT;
END;
PROCEDURE CALL;
BEGIN
XYGOTO(2,22); DRAW_HORIZ;
CALL_SUBSCRIBER;
CHECK_CONNECT;
END;
{$E+}
PROCEDURE PAINT_MENU_FRAME(HEADING: INTEGER);
VAR
N: INTEGER;
BEGIN
L_MARGIN := 0; T_MARGIN := 0; R_MARGIN := 79; B_MARGIN := 24;
ATTR := HILT; {- high lighted -}
CLR_S_WND;
MISC_PARMS[8] := HEADING;
PUTCONSTR(HEADING,6,2);
ATTR := NORMAL;
CLR_L_WND;
INIT_MENU;
WTANS := WAIT_PERIOD;
IF NOT REPAINT THEN EXIT;
XYGOTO(1, 1);
PUT_CHR(CHR(201));
DRAW_HORIZ;
PUT_CHR(CHR(187));
PUT_CHR(CHR(186));
XYGOTO(80,2);
PUT_CHR(CHR(186)); PUT_CHR(CHR(186));
XYGOTO(80,3);
PUT_CHR(CHR(186)); PUT_CHR(CHR(204));
DRAW_HORIZ;
PUT_CHR(CHR(185)); PUT_CHR(CHR(186));
FOR N := 5 TO 24 DO
BEGIN
XYGOTO(80,N);
PUT_CHR(CHR(186));
PUT_CHR(CHR(186));
END;
XYGOTO(1,22); PUT_CHR(CHR(204)); DRAW_HORIZ; PUT_CHR(CHR(185));
XYGOTO(1,25); PUT_CHR(CHR(200)); DRAW_HORIZ; PUT_CHR(CHR(188));
PUTCONSTR(PRX,106,25);
IF HELPANS THEN PUTCONSTR(HLAN,100,0);
PUT_MODE;
ATTR := HILT; XYGOTO(60,1); WRITE([ADDR(PUT_CHR)],DATE);
ATTR := NORMAL;
CHECK_CONNECT;
NOREPNT;
END;
PROCEDURE MAIN_MENU;
VAR
CH: CHAR;
BEGIN
WAIT_PERIOD := WTANS;
MISC_PARMS[4] := 0;
FUNCS[1] := 1; { ENABLE ANSWER }
FUNCS[8] := 1; { ENABLE HELP }
FUNCS[20] := 1; { ENABLE TRANSMIT ABORT }
REPNT;
HELPANS := TRUE;
PUT_DATE(SYS_DATE,'M');
DATE := ISTR;
REPEAT
PAINT_MENU_FRAME(TMN);
PUT_SELECTION(PNS);
PUT_SELECTION(TMM);
PUT_SELECTION(TSD);
PUT_SELECTION(OXF);
PUT_SELECTION(CNS);
PUT_SELECTION(DTN);
IF MISC_PARMS[4] = 0 THEN IN_TOP_LEVEL := TRUE;
CH := MENU_DRIVER('PTSACD',3);
IN_TOP_LEVEL := FALSE;
SHORT_WAIT;
CASE CH OF
'P': PREP_MENU;
'T': MANG_MENU;
'S': PHONE;
'A': AUX_MENU;
'C': IF TEST_PSWD(2,23) THEN CONFIG;
'D': CALL;
'Q': IF MISC_PARMS[4] <> 0 THEN
CALL
ELSE IF QUIT THEN
EXIT;
END;
UNTIL FALSE;
END;
{$E+}
{added procs for testing 1.4}
procedure test_353;
var
lv: longint;
a,b: integer;
procedure nested_353;
var
a,c: integer;
begin
lv := #5;
a := 4;
b := 5;
c := 6;
end;
begin
nested_353;
lv := #123456; {long integer literal}
a := 123; {integer literal}
b := $123; {hex literal}
a := ~a; {bitwise not}
a := \a; {bitwise not}
a := ?a; {bitwise not}
a := a | b; {bitwise or}
writeln([],'special case'); {no output routine given}
write([addr(putchar)],lv); {indirect write}
readln([],a); {no input routine given}
readln([addr(getchar)],b); {indirect read}
end;
MODEND.
(* ---- end of module ( separate compilation -----*)